(DECLARE (SETQ NO-DISK-HACKS T))
(DECLARE (REQUIRE UTIL 1 DSK (AID RPG)))
(DECLARE (READ))
(REQUIRE UTIL 1 DSK (AID RPG))


(DEFPROP COMPFCNS
 (COMPFCNS HELP-LCOM
	   COMPL
	   COMP
	   SUBSTACK
	   PRUP
	   MKPUSH
	   COMPEXP
	   STACKUP
	   CCCHAIN
	   COMPC
	   COMCOND
	   COMPLISA
	   CCOUNT
	   LOADAC
	   COMPLIS
	   CLASSIFY
	   CLASS1
	   CLASS2
	   MKJRST
	   COMBOOL
	   COMPANDOR
	   COMPANDOR1
	   FLAT)
VALUE)
 

(DEFUN HELP-LCOM NIL 
       (PROG NIL 
	     (TERPRI)
	     (PRINC
	      '
|(COMPL FOO LSP) compiles the DEFUN's in the file FOO.LSP |)
	     (TERPRI)
	     (PRINC '|    and writes the code on FOO.LAP |)
	     (TERPRI)
	     'END-HELP))
 


(DEFPROP COMPL
 (LAMBDA(FILE)
  (UWRITE)
  (APPLY (QUOTE EREAD) FILE)
  (SELECT-DISK-INPUT
   (READ-UNTIL-EOF
    WITH
    Z
    DO
    (COND ((OR (EQ (CAR Z) (QUOTE DEFUN)) (AND (EQ (CAR Z) (QUOTE DEFPROP)) (EQ (CADDDR Z) (QUOTE EXPR))))
	   (PROG (PROG)
		 (SETQ PROG
		       (COND ((EQ (CAR Z) (QUOTE DEFUN)) (COMP (CADR Z) (CADDR Z) (CADDDR Z)))
			     (T (COMP (CADR Z) (CADR (CADDR Z)) (CADDR (CADDR Z))))))
		 (UNSELECT-TTY (SELECT-DISK-OUTPUT (MAPC (FUNCTION PRINT) PROG)))
		 (PRINT (LIST (CADR Z) (LENGTH PROG)))))
	  (T (UNSELECT-TTY (SELECT-DISK-OUTPUT (PRINT Z))))))
   (APPLY (QUOTE UFILE) (LIST (CAR FILE) (QUOTE LAP)))
   (QUOTE ENDCOMP)))
FEXPR)

(DEFPROP COMP
 (LAMBDA(FN VARS EXP)
  ((LAMBDA(VPR N)
    (FLAT (LIST	(LIST (LIST (QUOTE LAP) FN (QUOTE SUBR)))
		(MKPUSH N 1)
		(COMPEXP EXP (MINUS N) VPR)
		(SUBSTACK N)
		(QUOTE ((POPJ P) (LABEL NIL))))
	  NIL))
   (PRUP VARS 1)
   (LENGTH VARS)))
EXPR)

(DEFPROP SUBSTACK
 (LAMBDA(N)
  (COND	((EQ N 0) NIL)
	(T
	 (LIST
	  (LIST (QUOTE SUB) (QUOTE P) (LIST (QUOTE %) 0 0 N N))))))
EXPR)

(DEFPROP PRUP
 (LAMBDA(VARS N)
  (COND	((NULL VARS) NIL)
	(T (CONS (CONS (CAR VARS) N) (PRUP (CDR VARS) (PLUS N 1))))))
EXPR)

(DEFPROP MKPUSH
 (LAMBDA(N M)
  (COND	((LESSP N M) NIL)
	(T
	 (CONS (LIST (QUOTE PUSH) (QUOTE P) M)
	       (MKPUSH N (PLUS M 1))))))
EXPR)

(DEFPROP COMPEXP
 (LAMBDA(EXP M VPR)
  (COND	((NULL EXP) (QUOTE ((MOVEI 1 0))))
	((OR (EQ EXP  T ) (NUMBERP EXP))
	 (LIST (LIST (QUOTE MOVEI) 1 (LIST (QUOTE QUOTE) EXP))))
	((ATOM EXP)
	 (LIST
	  (LIST	(QUOTE MOVE)
		1
		(PLUS M (CDR (ASSOC EXP VPR)))
		(QUOTE P))))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ)
		       1
      		       (QUOTE @)
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HLRZ 1 @ 1)))))))
	((EQ (CAR EXP) (QUOTE CDR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HRRZ)
		       1
		       (QUOTE @)
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(LIST (COMPEXP (CADR EXP) M VPR)
		      (QUOTE ((HRRZ 1 @ 1)))))))
	((OR (EQ (CAR EXP) (QUOTE AND))
	     (EQ (CAR EXP) (QUOTE OR))
	     (EQ (CAR EXP) (QUOTE NOT))
	     (EQ (CAR EXP) (QUOTE EQ)))
	 ((LAMBDA(L1 L2)
	   (LIST (COMBOOL EXP M L1 NIL VPR)
		 (LIST (QUOTE (MOVEI 1 (QUOTE T)))
		       (LIST (QUOTE JRST) 0 L2)
		       (LIST (QUOTE LABEL) L1)
		       (QUOTE (MOVEI 1 0))
		       (LIST (QUOTE LABEL) L2))))
	  (GENSYM)
	  (GENSYM)))
	((EQ (CAR EXP) (QUOTE COND))
	 (COMCOND (CDR EXP) M (GENSYM) VPR))
	((EQ (CAR EXP) (QUOTE QUOTE))
	 (LIST (LIST (QUOTE MOVEI) 1 EXP)))
	((ATOM (CAR EXP))
	 (LIST (COMPLISA (CDR EXP) M VPR)
	       (LIST
		(LIST (QUOTE CALL)
		      (LENGTH (CDR EXP))
		      (LIST (QUOTE QUOTE) (CAR EXP))))))
	((EQ (CAAR EXP) (QUOTE LAMBDA))
	 ((LAMBDA(N)
	   (LIST (STACKUP (CDR EXP) M VPR)
		 (COMPEXP
		  (CADDAR EXP)
		  (DIFFERENCE M N)
		  (APPEND (PRUP (CADAR EXP) (DIFFERENCE 1 M)) VPR))
		 (SUBSTACK N)))
	  (LENGTH (CDR EXP))))
	( T   NIL )))
EXPR)

(DEFPROP STACKUP
 (LAMBDA(U M VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMPEXP (CAR U) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (STACKUP (CDR U) (DIFFERENCE M 1) VPR)))))
EXPR)

(DEFPROP CCCHAIN
 (LAMBDA(EXP)
  (AND (OR (EQ (CAR EXP) (QUOTE CAR)) (EQ (CAR EXP) (QUOTE CDR)))
       (OR (ATOM (CADR EXP)) (CCCHAIN (CADR EXP)))))
EXPR)

(DEFPROP COMPC
 (LAMBDA(EXP N2 M VPR)
  (COND	((ATOM EXP) (ERR (QUOTE COMPC)))
	((EQ (CAR EXP) (QUOTE CAR))
	 (COND ((ATOM (CADR EXP))
		(LIST
		 (LIST (QUOTE HLRZ)
		       N2
		       (QUOTE @)
		       (PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		       (QUOTE P))))
	       (T
		(CONS (LIST (QUOTE HLRZ) N2 (QUOTE @) N2)
		      (COMPC (CADR EXP) N2 M VPR)))))
	((ATOM (CADR EXP))
	 (LIST
	  (LIST	(QUOTE HRRZ)
		N2
		(QUOTE @)
		(PLUS M (CDR (ASSOC (CADR EXP) VPR)))
		(QUOTE P))))
	(T
	 (CONS (LIST (QUOTE HRRZ) (QUOTE @) N2 N2)
	       (COMPC (CADR EXP) N2 M VPR)))))
EXPR)

(DEFPROP COMCOND
 (LAMBDA(U M L VPR)
  (COND	((NULL U) (LIST (LIST (QUOTE LABEL) L)))
	((AND (NOT (ATOM (CAAR U)))
	      (EQ (CAAAR U) (QUOTE NULL))
	      (NULL (CADAR U)))
	 (LIST (COMPEXP (CADAAR U) M VPR)
	       (LIST (LIST (QUOTE JUMPE) 1 L))
	       (COMCOND (CDR U) M L VPR)))
	((EQ (CAAR U)  T )
	 (LIST (COMPEXP (CADAR U) M VPR)
	       (LIST (LIST (QUOTE LABEL) L))))
	(T
	 ((LAMBDA(L1)
	   (LIST (COMBOOL (CAAR U) M L1 NIL VPR)
		 (COMPEXP (CADAR U) M VPR)
		 (LIST (LIST (QUOTE JRST) 0 L)
		       (LIST (QUOTE LABEL) L1))
		 (COMCOND (CDR U) M L VPR)))
	  (GENSYM)))))
EXPR)

(DEFPROP COMPLISA
 (LAMBDA(U M VPR)
  ((LAMBDA(Z)
    (LIST (COMPLIS Z M 1 VPR)
	  (LOADAC Z
		  (DIFFERENCE 1 (CCOUNT Z))
		  1
		  (DIFFERENCE M (CCOUNT Z))
		  VPR)
	  (SUBSTACK (CCOUNT Z))))
   (CLASSIFY U)))
EXPR)

(DEFPROP CCOUNT
 (LAMBDA(Z)
  (COND	((NULL Z) 0)
	((EQ (CAAR Z) 4) (PLUS 1 (CCOUNT (CDR Z))))
	(T (CCOUNT (CDR Z)))))
EXPR)

(DEFPROP LOADAC
 (LAMBDA(Z M2 N2 M VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 1)
	 (CONS (LIST (QUOTE MOVE)
		     N2
		     (PLUS M (CDR (ASSOC (CDAR Z) VPR)))
		     (QUOTE P))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 0)
	 (CONS (LIST (QUOTE MOVEI) N2 (LIST (QUOTE QUOTE) (CDAR Z)))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 2)
	 (CONS (LIST (QUOTE MOVEI) N2 (CDAR Z))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 3)
	 (LIST (REVERSE (COMPC (CDAR Z) N2 M VPR))
	       (LOADAC (CDR Z) M2 (PLUS N2 1) M VPR)))
	((EQ (CAAR Z) 5) (LOADAC (CDR Z) 1 (PLUS N2 1) M VPR))
	(T
	 (CONS (LIST (QUOTE MOVE) N2 M2 (QUOTE P))
	       (LOADAC (CDR Z) (PLUS M2 1) (PLUS N2 1) M VPR)))))
EXPR)

(DEFPROP COMPLIS
 (LAMBDA(Z M K VPR)
  (COND	((NULL Z) NIL)
	((EQ (CAAR Z) 4)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (QUOTE ((PUSH P 1)))
	       (COMPLIS (CDR Z) (DIFFERENCE M 1) (PLUS K 1) VPR)))
	((EQ (CAAR Z) 5)
	 (LIST (COMPEXP (CDAR Z) M VPR)
	       (COND ((EQ K 1) NIL)
		     (T (LIST (LIST (QUOTE MOVE) K 1))))))
	(T (COMPLIS (CDR Z) M (PLUS K 1) VPR))))
EXPR)

(DEFPROP CLASSIFY
 (LAMBDA (U) (CLASS2 (CLASS1 U NIL) NIL T))
EXPR)

(DEFPROP CLASS1
 (LAMBDA(U V)
  (COND	((NULL U) V)
	((ATOM (CAR U))
	 (COND ((OR (EQUAL (CAR U)  NIL )
		    (EQUAL (CAR U)  T )
		    (NUMBERP (CAR U)))
		(CLASS1 (CDR U) (CONS (CONS 0 (CAR U)) V)))
	       (T (CLASS1 (CDR U) (CONS (CONS 1 (CAR U)) V)))))
	((EQUAL (CAAR U) (QUOTE QUOTE))
	 (CLASS1 (CDR U) (CONS (CONS 2 (CAR U)) V)))
	((CCCHAIN (CAR U))
	 (CLASS1 (CDR U) (CONS (CONS 3 (CAR U)) V)))
	(T (CLASS1 (CDR U) (CONS (CONS 4 (CAR U)) V)))))
EXPR)

(DEFPROP CLASS2
 (LAMBDA(U V FLG)
  (COND	((NULL U) V)
	((AND FLG (EQ (CAAR U) 4))
	 (CLASS2 (CDR U) (CONS (CONS 5 (CDAR U)) V) NIL))
	(T (CLASS2 (CDR U) (CONS (CAR U) V) FLG))))
EXPR)

(DEFPROP MKJRST
 (LAMBDA (L) (LIST (LIST (QUOTE JRST) 0 L)))
EXPR)

(DEFPROP COMBOOL
 (LAMBDA(P M L FLG VPR)
  (COND	((EQ P  T ) (COND (FLG (MKJRST L)) (T NIL)))
	((ATOM P)
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))
	((EQ (CAR P) (QUOTE EQ))
	 (LIST (COMPLISA (CDR P) M VPR)
	       (COND (FLG (QUOTE ((CAMN 1 2))))
		     (T (QUOTE ((CAME 1 2)))))
	       (MKJRST L)))
	((EQ (CAR P) (QUOTE AND))
	 (COND ((NOT FLG) (COMPANDOR (CDR P) M L NIL VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L NIL VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE OR))
	 (COND (FLG (COMPANDOR (CDR P) M L T VPR))
	       (T
		((LAMBDA(L1)
		  (LIST	(COMPANDOR1 (CDR P) M L1 L T VPR)
			(LIST (LIST (QUOTE LABEL) L1))))
		 (GENSYM)))))
	((EQ (CAR P) (QUOTE NOT))
	 (COMBOOL (CADR P) M L (NOT FLG) VPR))
	((EQ (CAR P) (QUOTE NULL))
	 (LIST (COMPEXP (CADR P) M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPE)) (T (QUOTE JUMPN)))
		      1
		      L))))
	(T
	 (LIST (COMPEXP P M VPR)
	       (LIST
		(LIST (COND (FLG (QUOTE JUMPN)) (T (QUOTE JUMPE)))
		      1
		      L))))))
EXPR)

(DEFPROP COMPANDOR
 (LAMBDA(U M L FLG VPR)
  (COND	((NULL U) NIL)
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR (CDR U) M L FLG VPR)))))
EXPR)

(DEFPROP COMPANDOR1
 (LAMBDA(U M L L2 FLG VPR)
  (COND	((NULL U) (MKJRST L2))
	((NULL (CDR U)) (COMBOOL (CAR U) M L2 (NOT FLG) VPR))
	(T
	 (LIST (COMBOOL (CAR U) M L FLG VPR)
	       (COMPANDOR1 (CDR U) M L L2 FLG VPR)))))
EXPR)

(DEFPROP FLAT
 (LAMBDA(U S)
  (COND	((NULL U) S)
	((NULL (CAR U)) (FLAT (CDR U) S))
	((EQ (CAR U) (QUOTE LABEL)) (CONS (CADR U) S))
	((ATOM (CAR U)) (CONS U S))
	(T (FLAT (CAR U) (FLAT (CDR U) S)))))
EXPR)